home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gwuada_9.zip / 3B.C < prev    next >
C/C++ Source or Header  |  1993-07-27  |  57KB  |  1,849 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #include "3.h"
  11. #include "attr.h"
  12. #include "setp.h"
  13. #include "dclmapp.h"
  14. #include "errmsgp.h"
  15. #include "evalp.h"
  16. #include "nodesp.h"
  17. #include "miscp.h"
  18. #include "smiscp.h"
  19. #include "chapp.h"
  20.  
  21. static void new_unconstrained_array(Symbol, Node);
  22. static Symbol constrain_index(Symbol, Node);
  23. static void discr_decl(Node);
  24. static Tuple process_anons(Tuple);
  25. static int reformat_requires(Node);
  26.  
  27. Tuple apply_range(Node range_expr) /*;apply_range*/
  28. {
  29.     /* A'RANGE is equivalent to A'FIRST..A'LAST. When the range attribute
  30.      * is used as a constraint, the bounds are expressed according to the
  31.      * above equivalence. This is not strictly correct if the elaboration
  32.      * of A has side-effects, but we ignore this detail for now.
  33.      */
  34.  
  35.     Node    attr, arg1, arg2;
  36.     Tuple    new_c;
  37.     Node    l_node, f_node;
  38.     int    f, l, attr_kind;
  39.  
  40.     if (N_KIND(range_expr) == as_qual_range)
  41.         /* discard spurious constraint. */
  42.         range_expr = N_AST1(range_expr);
  43.     attr = N_AST1(range_expr);
  44.     arg1 = N_AST2(range_expr);
  45.     arg2 = N_AST3(range_expr);
  46.  
  47.     /* The attribute is either O_RANGE or T_RANGE, according as arg1 is an
  48.      * object or a type. FIRST and LAST must be marked accordingly.
  49.      */
  50.     /* In C note that base attribute kind followed by O_ kind, then T_. */
  51.     attr_kind = (int) attribute_kind(range_expr);
  52.  
  53.     if (attr_kind == ATTR_O_RANGE) {
  54.         f = ATTR_O_FIRST;
  55.         l = ATTR_O_LAST;
  56.     }
  57.     else {
  58.         f = ATTR_T_FIRST;
  59.         l = ATTR_T_LAST;
  60.     }
  61.  
  62.     f_node = new_attribute_node(f, arg1, arg2, N_TYPE(range_expr));
  63.     l_node = new_attribute_node(l, copy_tree(arg1), copy_tree(arg2),
  64.       N_TYPE(range_expr));
  65.  
  66.     N_KIND(range_expr) = as_range;
  67.     N_AST1(range_expr) = f_node;
  68.     N_AST2(range_expr) = l_node;
  69.  
  70.     /*return ?? ['range', f_node, l_node];*/
  71.     new_c = constraint_new(CONSTRAINT_RANGE);
  72.     numeric_constraint_low(new_c) = (char *) f_node;
  73.     numeric_constraint_high(new_c) = (char *) l_node;
  74.     return new_c;
  75. }
  76.  
  77. void array_typedef(Node node)                                /*;array_typedef*/
  78. {
  79.     Node index_list_node, type_indic_node;
  80.     Tuple index_nodes;
  81.     Node indx_node, indx1_node;
  82.     Tuple index_type_list;
  83.     Symbol    element_type;
  84.     int i, exists;
  85.     Fortup    ft1;
  86.  
  87.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : array_typedef");
  88.  
  89.     index_list_node = N_AST1(node);
  90.     type_indic_node = N_AST2(node);
  91.     sem_list(index_list_node);
  92.     index_nodes = N_LIST(index_list_node);
  93.  
  94.     index_type_list =  tup_new(tup_size(index_nodes));
  95.     FORTUPI(indx_node =(Node), index_nodes, i, ft1);
  96.         index_type_list[i] = (char *) make_index(indx_node);
  97.     ENDFORTUP(ft1);
  98.  
  99.     adasem(type_indic_node);
  100.     element_type = promote_subtype(make_subtype(type_indic_node));
  101.  
  102.     /* Validate an array type definition.*/
  103.  
  104.     exists = FALSE;
  105.     FORTUP(indx_node =(Node) , index_nodes, ft1);
  106.         if (N_KIND(indx_node) == as_box) {
  107.             exists = TRUE;
  108.             break;
  109.         }
  110.     ENDFORTUP(ft1);
  111.     if (exists) {
  112.         exists = FALSE;
  113.         /*Unconstrained array . Verify that all indices are unconstrained.*/
  114.         FORTUP(indx1_node = (Node), index_nodes, ft1);
  115.             if (N_KIND(indx1_node) != as_box) {
  116.                 exists = TRUE;
  117.                 break;
  118.             }
  119.         ENDFORTUP(ft1);
  120.         if (exists) {
  121.             errmsg("Constraints apply to all indices or none", "3.6.1", node);
  122.         }
  123.     }
  124.     if (is_unconstrained(element_type)) {
  125.         errmsg("Unconstrained element type in array declaration",
  126.           "3.6.1, 3.7.2", type_indic_node);
  127.     }
  128.     check_fully_declared2(element_type);
  129.  
  130.     for (i = 1; i<= tup_size(index_nodes); i++) {
  131.         Node tmp = (Node) index_nodes[i];
  132.         N_UNQ(tmp) = (Symbol) (index_type_list[i]);
  133.     }
  134.     N_UNQ(type_indic_node) = element_type;
  135. }
  136.  
  137. void new_array_type(Symbol array_type, Node def_node)  /*;new_array_type*/
  138. {
  139.     /* This     procedure  is    called    whenever  an array type is created.
  140.      * For each new array type we create a corresponding sequence type,
  141.      * which is an unconstrained  array. Unconstrained array types have
  142.      * nature na_array, while constrained arrays have nature na_subtype.
  143.      */
  144.  
  145.     Node    index_list_node;
  146.     Tuple    tn;
  147.     Node    tnn;
  148.  
  149.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : new_array_type(array_type");
  150.  
  151.     adasem(def_node);
  152.     index_list_node = N_AST1(def_node);
  153.  
  154.     tn =  N_LIST(index_list_node);
  155.     tnn = (Node) tn[1];
  156.     if (N_KIND(tnn) == as_box)
  157.         /* Unconstrained array definition. In this case, introduce only the*/
  158.         /* unconstrained type, and ignore the actual array type.*/
  159.         new_unconstrained_array(array_type, def_node);
  160.     else
  161.         new_constrained_array(array_type, def_node);
  162. }
  163.  
  164. static void new_unconstrained_array(Symbol sequence_type, Node def_node)
  165.                                                     /*;new_unconstrained_array*/
  166. {
  167.     Node index_list_node, type_indic_node, indx_node;
  168.     Fortup    ft1;
  169.     int    i, l;
  170.     Tuple    index_list, array_info;
  171.     Symbol    comp;
  172.  
  173.     index_list_node= N_AST1(def_node);
  174.     type_indic_node = N_AST2(def_node);
  175.     /*index_list := [N_UNQ(indx_node) : indx_node in N_LIST(index_list_node)];*/
  176.     index_list = tup_new(tup_size(N_LIST(index_list_node)));
  177.     FORTUPI(indx_node=(Node), N_LIST(index_list_node), i, ft1);
  178.         index_list[i] = (char *) N_UNQ(indx_node);
  179.     ENDFORTUP(ft1);
  180.     /*??array_info := [index_list, N_UNQ(type_indic_node)];*/
  181.     array_info = tup_new(2);
  182.     array_info[1] = (char *) index_list;
  183.     comp = N_UNQ(type_indic_node);
  184.     array_info[2] = (char *) comp;
  185.     /*SYMBTAB(sequence_type) := [na_array, sequence_type, array_info];*/
  186.     NATURE(sequence_type) = na_array;
  187.     TYPE_OF(sequence_type) = sequence_type;
  188.     SIGNATURE(sequence_type) = array_info;
  189.     /*Mark the type as limited if the component type is.*/
  190.     if (is_access(comp))
  191.         misc_type_attributes(sequence_type) = 0;
  192.     else {
  193.         l= (int) private_kind(comp);
  194.         misc_type_attributes(sequence_type) = l;
  195.     }
  196.     root_type(sequence_type) = sequence_type;
  197.     initialize_representation_info(sequence_type,TAG_ARRAY);
  198.  
  199.     /* For each unconstrained array type, we introduce an instance of the
  200.      * 'aggregate' pseudo-operator for that array.
  201.      */
  202.     new_agg_or_access_agg(sequence_type);
  203. }
  204.  
  205. void new_constrained_array(Symbol array_type, Node def_node)
  206.                                                     /*;new_constrained_array*/
  207. {
  208.     char    *nam;
  209.     Fortup    ft1;
  210.     Symbol    sequence_type;
  211.     Tuple    t, index_list, array_info;
  212.     Node    index_list_node, type_indic_node, indx_node;
  213.     int    i;
  214.     char    *sequence_type_name;
  215.  
  216.     /* Construct meaningful name for anonymous parent type.*/
  217.     nam = original_name(array_type);
  218.     if (strcmp(nam , "") == 0) nam = "anonymous_array";
  219.     sequence_type_name = strjoin(nam , strjoin("\'base" , newat_str()));
  220.     sequence_type = sym_new(na_void);
  221.     dcl_put(DECLARED(scope_name), sequence_type_name, sequence_type);
  222.     SCOPE_OF(sequence_type) = SCOPE_OF(array_type);
  223.     /* emit sequence type as an anonymous type. It is used in aggregates
  224.      * that are assigned to slices, and in other unconstrained contexts.
  225.      * (This should only be needed for one dimensional arrays).
  226.      */
  227.     /*top(NEWTYPES) with:= sequence_type;*/
  228.     t = (Tuple) newtypes[tup_size(newtypes)];
  229.     t = tup_with(t, (char *) sequence_type);
  230.     newtypes[tup_size(newtypes)] = (char *) t;
  231.     new_unconstrained_array(sequence_type, def_node);
  232.  
  233.     /* Make the actual array type into a subtype of the unconstrained one*/
  234.  
  235.     index_list_node = N_AST1(def_node);
  236.     type_indic_node = N_AST2(def_node);
  237.     index_list = tup_new(tup_size(N_LIST(index_list_node)));
  238.     FORTUPI(indx_node = (Node), N_LIST(index_list_node), i, ft1);
  239.         index_list[i] = (char *) N_UNQ(indx_node);
  240.     ENDFORTUP(ft1);
  241.     /*array_info := [index_list, N_UNQ(type_indic_node)];*/
  242.     array_info = tup_new(2);
  243.     array_info[1] = (char *) index_list;
  244.     array_info[2] = (char *) N_UNQ(type_indic_node);
  245.     /*??SYMBTAB(array_type) = [na_subtype, sequence_type, array_info];*/
  246.     NATURE(array_type) = na_subtype;
  247.     TYPE_OF(array_type) = sequence_type;
  248.     SIGNATURE(array_type) = array_info;
  249.     misc_type_attributes(array_type) = misc_type_attributes(sequence_type);
  250.     root_type(array_type) = sequence_type;
  251. }
  252.  
  253. Symbol anonymous_array(Node node) /*;anonymous_array*/
  254. {
  255.     /* Process an array definition in an object or constant declaration.
  256.      * The node is an array_type node.
  257.      */
  258.  
  259.     Symbol typ;
  260.     Tuple    t;
  261.  
  262.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : anonymous_array");
  263.  
  264.     typ =    find_new(strjoin("anon", newat_str()));      /*Create  a  name for it*/
  265.     new_array_type(typ, node);    /*elaborate   definition*/
  266.     /*??top(NEWTYPES) with